home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / XLisp 2.1e3 / lisp / pp.lsp < prev    next >
Lisp/Scheme  |  1992-10-29  |  16KB  |  487 lines
  1. ; PP.LSP -- a pretty-printer for XLISP.
  2.  
  3. ; Adapted by Jim Chapman (Bix: jchapman) from a program written originally
  4. ; for IQLISP by Don Cohen.  Copyright (c) 1984, Don Cohen; (c) 1987, Jim
  5. ; Chapman.  Permission for non-commercial use and distribution is hereby 
  6. ; granted.  Modified for XLISP 2.0 by David Betz.
  7.  
  8. ; In addition to the pretty-printer itself, this file contains a few functions
  9. ; that illustrate some simple but useful applications.
  10.  
  11. ; The basic function accepts two arguments:
  12.  
  13. ;      (PP OBJECT STREAM)
  14.  
  15. ; where OBJECT is any Lisp expression, and STREAM optionally specifies the
  16. ; output (default is *standard-output*).
  17.  
  18. ; PP-FILE pretty-prints an entire file.  It is what I used to produce this
  19. ; file (before adding the comments manually).  The syntax is:
  20.  
  21. ;       (PP-FILE "filename" STREAM)
  22.  
  23. ; where the file name must be a string or quoted, and STREAM, again, is the
  24. ; optional output destination.
  25.  
  26. ; PP-DEF works just like PP, except its first argument is assumed to be the
  27. ; name of a function or macro, which is translated back into the original
  28. ; DEFUN or DEFMACRO form before printing.
  29.  
  30.  
  31. ; MISCELLANEOUS USAGE AND CUSTOMIZATION NOTES:
  32.  
  33. ; 1.  The program uses tabs whenever possible for indentation.
  34. ;     This greatly reduces the cost of the blank space.  If your output
  35. ;     device doesn't support tabs, set TABSIZE to NIL -- which is what I
  36. ;     did when I pretty-printed this file, because of uncertainty 
  37. ;     about the result after uploading.
  38.  
  39. ; 2.  Printmacros are used to handle special forms.  A printmacro is not
  40. ;     really a macro, just an ordinary lambda form that is stored on the
  41. ;     target symbol's property list.  The default printer handles the form
  42. ;     if there is no printmacro or if the printmacro returns NIL.
  43.  
  44. ; 3.  Note that all the pretty-printer subfunctions, including the
  45. ;     the printmacros, return the current column position.
  46.  
  47. ; 4.  Miser mode is not fully implemented in this version, mainly because  
  48. ;     lookahead was too slow.  The idea is, if the "normal" way of
  49. ;     printing the current expression would exceed the right margin, then
  50. ;     use a mode that conserves horizontal space.
  51.  
  52. ; 5.  When PP gets to the last 8th of the line and has more to print than
  53. ;     fits on the line, it starts near the left margin.  This is not 
  54. ;     wonderful, but neither are the alternatives.  If you have a better
  55. ;     idea, go for it.
  56.  
  57. ;  6. Storage requirements are about 1450 cells to load.  
  58.  
  59. ;  7. I tested this with XLISP 1.7 on an Amiga.
  60.  
  61. ;  8. TAA modified to support prettyprinting arrays.  Fixed bug printing
  62. ;     (NIL ...).
  63.  
  64. ;  9. TAA modified to support prettyprinting of structures, and some code
  65. ;     cleanup. Also added PP-PAIR-FORM to handle setq like structures
  66. ;     more nicely. 
  67.  
  68. ; 10. TAA: It should be noted that you can't pretty print circular lists,
  69. ;     nor can you successfully read back the following:
  70. ;    * uninterned symbols, for instance those generated with gensym
  71. ;         as part of automatically generated code
  72. ;       * closures, since their environment cannot be reconstructed. These
  73. ;         are not even expanded.
  74. ;       * subrs, fsubrs, and streams cannot be represented
  75.  
  76. ; 11. TAA modified so that non-class objects are shown by sending the
  77. ;    message :storeon (see classes.lsp), printing #. before the expression
  78. ;    making it an object literal.
  79.  
  80. ; 11. TAA modified so that *print-level* and *print-length* are bound to  NIL
  81. ;    during the course of execution.
  82.  
  83. ; An ugly false def so things don't fall apart if classes.lsp not loaded
  84. #-:classes (defun classp (x) (objectp x))
  85.  
  86.  
  87.  
  88.  
  89. ;(DEFUN SYM-FUNCTION (X)    ;for Xlisp 1.7
  90. ;    (CAR (SYMBOL-VALUE X)))
  91. (defun sym-function (x)        ;for Xlisp 2.0
  92.     (get-lambda-expression (symbol-function x)))
  93.  
  94. (defvar tabsize 8)    ;set this to NIL for no tabs
  95.  
  96. (defvar maxsize 60)    ;for readability, PP tries not to print more
  97.             ;than this many characters on a line
  98.  
  99. (defvar miser-size 2)    ;the indentation in miser mode
  100.  
  101. (defvar min-miser-car 4)    ;used for deciding when to use miser mode
  102.  
  103. (defvar max-normal-car 9)    ;ditto
  104.  
  105. (defconstant pp-lpar "(")    ; self evident
  106. (defconstant pp-rpar ")")
  107. (defconstant pp-space " ")
  108. (defconstant pp-immed "#.")
  109.  
  110. ; The following function prints a file
  111.  
  112. (defun pp-file (filename &optional streamout)
  113.     (or streamout (setq streamout *standard-output*))
  114.     (princ "; Listing of " streamout)
  115.     (princ filename streamout)
  116.     (terpri streamout)
  117.     (terpri streamout)
  118.     (do* ((fp (open filename)) (expr (read fp) (read fp)))
  119.          ((null expr) (close fp))
  120.       (pp expr streamout)
  121.       (terpri streamout)))
  122.  
  123.  
  124. ; Print a lambda or macro form as a DEFUN or DEFMACRO:
  125.  
  126. (defmacro pp-def (who &optional stream)
  127.     `(pp (make-def ,who) ,stream))
  128.  
  129. (defmacro make-def (name &aux expr type)
  130.     (setq expr (sym-function name))
  131.     (setq type
  132.           (cadr (assoc (car expr)
  133.                        '((lambda defun) (macro defmacro)))))
  134.     (list 'quote
  135.           (append (list type name) (cdr expr))))
  136.  
  137.  
  138.  
  139. ; The pretty-printer high level function:
  140.  
  141.  
  142. (defun pp (x &optional stream)
  143.        (let (*print-level* *print-length*)    ; set special vars to NIL
  144.         (or stream (setq stream *standard-output*))
  145.         (pp1 x stream 1 80)
  146.         (terpri stream)
  147.         t))
  148.  
  149. ; print X on STREAM, current cursor is CURPOS, and right margin is RMARGIN
  150.  
  151. (defun pp1 (x stream curpos rmargin 
  152.           &aux (anarray (arrayp x))
  153.            (astruct (typep x '(and struct (not random-state))))
  154.            size position width)
  155.     (cond (anarray (setq x (coerce x 'cons)))
  156.       ((and (objectp x) (not (classp x)))
  157.        (princ pp-immed stream)        ; immediate execute literal
  158.        (setq curpos (+ curpos 2))
  159.        (setq x (send x :storeon))))
  160.     (cond (astruct (pp-astruct x stream curpos rmargin))
  161.       ((not (consp x))(prin1 x stream) (+ curpos (flatsize x)))
  162.           ((printmacrop x stream curpos rmargin))
  163.           ((and (> (flatsize x) (- rmargin curpos))
  164.                 (< (* 8 (- rmargin curpos)) rmargin))
  165.            (setq size (+ (/ rmargin 8) (- curpos rmargin)))
  166.            (pp-moveto stream curpos size)
  167.            (setq position (pp1 x stream size rmargin))
  168.            (pp-moveto stream position size))
  169.           (t (when anarray (princ "#" stream) (setq curpos (1+ curpos)))
  170.          (princ pp-lpar stream)
  171.              (setq position
  172.                    (pp1 (car x) stream (1+ curpos) rmargin))
  173.              (cond ((and (>= (setq width (- rmargin position))
  174.                              (setq size (flatsize (cdr x))))
  175.                          (<= size maxsize))
  176.                     (pp-rest-across (cdr x) stream position rmargin))
  177.                    ((consp (car x))
  178.                     (pp-moveto stream position curpos)
  179.                     (pp-rest (cdr x) stream curpos rmargin))
  180.                    ((> (- position curpos) max-normal-car)
  181.                     (pp-moveto stream position (+ curpos miser-size))
  182.                     (pp-rest (cdr x) stream (+ curpos miser-size) rmargin))
  183.                    (t (pp-rest (cdr x) stream position rmargin))))))
  184.  
  185. ; PP-MOVETO controls indentating and tabbing.
  186. ; If CUR > GOAL then goes to new line first.
  187. ; will space to GOAL
  188.  
  189. (defun pp-moveto (stream curpos goalpos &aux i)
  190.     (cond ((> curpos goalpos)
  191.            (terpri stream)
  192.            (setq curpos 1)
  193.            (if tabsize
  194.                (do nil
  195.                    ((< (- goalpos curpos) tabsize))
  196.                  (princ "\t" stream)
  197.                  (setq curpos (+ curpos tabsize))))))
  198.     (dotimes (i (- goalpos curpos)) (princ pp-space stream))
  199.     goalpos)
  200.  
  201. ; can print the rest of the list without new lines
  202.  
  203. (defun pp-rest-across (x stream curpos rmargin &aux position)
  204.     (setq position curpos)
  205.     (prog nil
  206.       lp
  207.       (cond ((null x) (princ pp-rpar stream) (return (1+ position)))
  208.             ((not (consp x))
  209.              (princ " . " stream)
  210.              (prin1 x stream)
  211.              (princ pp-rpar stream)
  212.              (return (+ 4 position (flatsize x))))
  213.             (t (princ pp-space stream)
  214.                (setq position
  215.                      (pp1 (car x) stream (1+ position) rmargin))
  216.                (setq x (cdr x))
  217.                (go lp)))))
  218.  
  219. ; Can print the rest of the list, but must use new lines for each element
  220.  
  221.  
  222. (defun pp-rest (x stream curpos rmargin &aux position pos2)
  223.     (setq position curpos)
  224.     (prog nil
  225.       lp
  226.       (cond ((null x) (princ pp-rpar stream) (return (1+ position)))
  227.             ((not (consp x))
  228.              (and (> (flatsize x) (- (- rmargin position) 3))
  229.                   (setq position (pp-moveto stream position curpos)))
  230.              (princ " . " stream)
  231.              (prin1 x stream)
  232.              (princ pp-rpar stream)
  233.              (return (+ position 4 (flatsize x))))
  234.             ((and 
  235.           (not (typep (car x) '(or list array struct)))
  236.                   (<= (setq pos2 (+ 1 position (flatsize (car x))))
  237.                       rmargin)
  238.                   (<= pos2 (+ curpos maxsize)))
  239.              (princ pp-space stream)
  240.              (prin1 (car x) stream)
  241.              (setq position pos2))
  242.             (t (pp-moveto stream position (1+ curpos))
  243.                (setq position
  244.                      (pp1 (car x) stream (1+ curpos) rmargin))))
  245.       (cond ((and (consp (car x)) (cdr x))
  246.              (setq position (pp-moveto stream position curpos))))
  247.       (setq x (cdr x))
  248.       (go lp)))
  249.  
  250.  
  251. ; Handles structures by printing in form:
  252. ;    #S(structtype :slot val
  253. ; ...
  254. ;              :slot val)
  255. ;
  256. ; code does not check for defaults.
  257.  
  258. (defun pp-astruct (x stream pos rmar &aux cur snames args)
  259.        (setq cur pos
  260.          snames (mapcar #'car (get (type-of x) '*struct-slots*))
  261.          args 
  262.          (mapcan #'(lambda (p) 
  263.                    (list p
  264.                      (apply
  265.                       (intern
  266.                        (strcat (string (type-of x)) 
  267.                            "-" 
  268.                            (string p)))
  269.                       (list x))))
  270.              snames))
  271.        (princ "#s" stream)
  272.        (if (and (>= (- rmar pos) (+ 2 (flatsize x)))
  273.         (<= (flatsize x) maxsize))
  274.        (pp1 (cons (type-of x) args) stream (+ 2 pos) rmar)
  275.        (prog ()
  276.          (princ pp-lpar stream)
  277.          (prin1 (type-of x) stream)
  278.          (princ pp-space stream)
  279.          (setq pos (setq cur (+ pos 4 (flatsize (type-of x)))))
  280.          lp
  281.          (prin1 (first args) stream)
  282.          (princ pp-space stream)
  283.          (setq cur
  284.                (pp1 (second args)
  285.                 stream
  286.                 (+ pos 1 (flatsize (first args)))
  287.                 rmar))
  288.          (setq args (cddr args))
  289.          (when (null args)
  290.                (princ pp-rpar stream)
  291.                (return-from pp-astruct (1+ cur)))
  292.          (pp-moveto stream cur pos)
  293.          (go lp))))
  294.  
  295.          
  296. ; PRINTMACROP is the printmacro interface routine.  Note that the
  297. ; called function has the same argument list as PP1.  It may either
  298. ; decide not to handle the form, by returning NIL (and not printing)
  299. ; or it may print the form and return the resulting position.
  300.  
  301. (defun printmacrop (x stream curpos rmargin &aux macro)
  302.     (and (symbolp (car x))
  303.      (car x)    ; must not be NIL (TAA fix)
  304.          (setq macro (get (car x) 'printmacro))
  305.          (apply macro (list x stream curpos rmargin))))
  306.  
  307. ; The remaining forms define various printmacros.
  308.  
  309.  
  310. ; Printing format (xxx xxx
  311. ;               <pp-rest>)
  312.  
  313.  
  314. (defun pp-binding-form (x stream pos rmar &aux cur)
  315.     (setq cur pos)
  316.     (cond ((and (>= (- rmar pos) (flatsize x))
  317.                 (<= (flatsize x) maxsize)) nil)
  318.           ((> (length x) 2)
  319.            (princ pp-lpar stream)
  320.            (prin1 (car x) stream)
  321.            (princ pp-space stream)
  322.            (setq cur
  323.                  (pp1 (cadr x)
  324.                       stream
  325.                       (+ 2 pos (flatsize (car x)))
  326.                       rmar))
  327.            (pp-moveto stream cur (+ pos 1))
  328.            (pp-rest (cddr x) stream (+ pos 1) rmar))))
  329.  
  330. ; Format (xxxx xxx xxx
  331. ;...
  332. ;           xxx xxx)
  333.  
  334. (defun pp-pair-form (x stream pos rmar &aux cur)
  335.     (setq cur pos)
  336.     (cond ((and (>= (- rmar pos) (flatsize x))
  337.                 (<= (flatsize x) maxsize)) nil)
  338.           ((> (length x) 1)
  339.            (princ pp-lpar stream)
  340.            (prin1 (first x) stream)
  341.            (princ pp-space stream)
  342.        (setq pos (setq cur (+ pos 2 (flatsize (first x)))))
  343.        (setq x (rest x))
  344.        (loop
  345.         (pp-moveto stream cur pos)
  346.         (setq cur (pp1 (first x) stream pos rmar))
  347.         (princ pp-space stream)
  348.         (setq x (rest x))
  349.         (setq cur (pp1 (first x) stream (1+ cur) rmar))
  350.         (when (null (setq x (rest x)))
  351.           (princ pp-rpar stream)
  352.           (return-from pp-pair-form (1+ cur)))))))
  353.  
  354. ; format (xxx xxx
  355. ;          xxx
  356. ;        <pprest>)
  357.  
  358.        
  359. (defun pp-do-form (x stream pos rmar &aux cur pos2)
  360.     (setq cur pos)
  361.     (cond ((and (>= (- rmar pos) (flatsize x))
  362.                 (<= (flatsize x) maxsize)) nil)
  363.           ((> (length x) 2)
  364.            (princ pp-lpar stream)
  365.            (prin1 (car x) stream)
  366.            (princ pp-space stream)
  367.            (setq pos2 (+ 2 pos (flatsize (car x))))
  368.            (setq cur (pp1 (cadr x) stream pos2 rmar))
  369.            (pp-moveto stream cur pos2)
  370.            (setq cur (pp1 (caddr x) stream pos2 rmar))
  371.            (pp-moveto stream cur (+ pos 1))
  372.            (pp-rest (cdddr x) stream (+ pos 1) rmar))))
  373.  
  374. ; format (xxx xxx xxx
  375. ;       <pprest>)
  376.  
  377. (defun pp-defining-form (x stream pos rmar &aux cur)
  378.     (setq cur pos)
  379.     (cond ((and (>= (- rmar pos) (flatsize x))
  380.                 (<= (flatsize x) maxsize)) nil)
  381.           ((> (length x) 3)
  382.            (princ pp-lpar stream)
  383.            (prin1 (car x) stream)
  384.            (princ pp-space stream)
  385.            (prin1 (cadr x) stream)
  386.            (princ pp-space stream)
  387.            (setq cur
  388.                  (pp1 (caddr x)
  389.                       stream
  390.                       (+ 3 pos (flatsize (car x)) (flatsize (cadr x)))
  391.                       rmar))
  392.            (pp-moveto stream cur (+ 3 pos))
  393.            (pp-rest (cdddr x) stream (+ 3 pos) rmar))))
  394.  
  395. (putprop 'quote
  396.          '(lambda (x stream pos rmargin)
  397.             (cond ((and (cdr x) (null (cddr x)))
  398.                    (princ "'" stream)
  399.                    (pp1 (cadr x) stream (1+ pos) rmargin))))
  400.          'printmacro)
  401.  
  402. (putprop 'backquote
  403.          '(lambda (x stream pos rmargin)
  404.             (cond ((and (cdr x) (null (cddr x)))
  405.                    (princ "`" stream)
  406.                    (pp1 (cadr x) stream (1+ pos) rmargin))))
  407.          'printmacro)
  408.  
  409. (putprop 'comma
  410.          '(lambda (x stream pos rmargin)
  411.             (cond ((and (cdr x) (null (cddr x)))
  412.                    (princ "," stream)
  413.                    (pp1 (cadr x) stream (1+ pos) rmargin))))
  414.          'printmacro)
  415.  
  416. (putprop 'comma-at
  417.          '(lambda (x stream pos rmargin)
  418.             (cond ((and (cdr x) (null (cddr x)))
  419.                    (princ ",@" stream)
  420.                    (pp1 (cadr x) stream (+ pos 2) rmargin))))
  421.          'printmacro)
  422.  
  423. (putprop 'function
  424.          '(lambda (x stream pos rmargin)
  425.             (cond ((and (cdr x) (null (cddr x)))
  426.                    (princ "#'" stream)
  427.                    (pp1 (cadr x) stream (+ pos 2) rmargin))))
  428.          'printmacro)
  429.  
  430. (putprop 'prog
  431.          'pp-binding-form
  432.          'printmacro)
  433.  
  434. (putprop 'prog*
  435.          'pp-binding-form
  436.          'printmacro)
  437.  
  438. (putprop 'let
  439.          'pp-binding-form
  440.          'printmacro)
  441.  
  442. (putprop 'let*
  443.          'pp-binding-form
  444.          'printmacro)
  445.  
  446. (putprop 'lambda
  447.          'pp-binding-form
  448.          'printmacro)
  449.  
  450. (putprop 'macro
  451.          'pp-binding-form
  452.          'printmacro)
  453.  
  454. (putprop 'do 'pp-do-form 'printmacro)
  455.  
  456. (putprop 'do*
  457.          'pp-do-form
  458.          'printmacro)
  459.  
  460. (putprop 'defun
  461.          'pp-defining-form
  462.          'printmacro)
  463.  
  464. (putprop 'defmacro
  465.          'pp-defining-form
  466.          'printmacro)
  467.  
  468.  
  469. (putprop 'setq
  470.      'pp-pair-form
  471.      'printmacro)
  472.  
  473. (putprop 'setf
  474.      'pp-pair-form
  475.      'printmacro)
  476.  
  477. (putprop 'psetq
  478.      'pp-pair-form
  479.      'printmacro)
  480.  
  481.  
  482. (putprop 'send
  483.      'pp-defining-form
  484.      'printmacro)
  485.  
  486.  
  487.